Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/mdishe/main.bas

BASIC Source File | 1994-12-28 | 14.4 KB | 535 lines

' ********************************************************
'        MDI Standard Application Shell
' ********************************************************
'
' SUMMARY
' -------
' This file is part of an MDI application "skeleton"
' created by John Blessing of Leigh Business Enterprises Ltd.
'
' FEATURES
' --------
' Selection of application database.
' Compact/Repair of database.
' 'Helptips' on toolbar items.
' Support for Help files.
' MDI child forms tiling etc.
' Error trapping.
' 'Nag' screen support for shareware authors.
' Support for 3D dialogs (switched off in design mode
'   to prevent GPFs)
'
' USE
' ---
' You need VB Pro to use this shell, although it could be
' modified to run under the standard edition.
'
' You will need to set up some information in APP.BAS,
' particularly in SetAppInfo().  You will also need to add
' your own application specific code to this module.
'
' DISTRIBUTION
' ------------
' This program is "FreeWare" and may be used and distributed
' as you wish.
'
' It incorporates some ideas/code from other authors and these
' are acknowledged in the appropriate module.
'
' We hope that you will find it useful.  If you wish to discuss it
' then please e-mail us on Compuserve 100444,623.
'
' ADVERTISEMENT!
' --------------
' Are you looking for a helpdesk system? Or does your company
' want to track and monitor the progress of any work activity?
' We market a system which could be of interest to you.
'
' PROGRESS is available for download from the Business section
' of the Windows Shareware forum on Compuserve
' (filename PRGRSS10.ZIP).  It's a large program, so in the
' same section you will also find the help files and
' documentation as  PRGSSDOC.ZIP which is quicker to download
' and will give you a good idea of the functionality of PROGRESS.
'
' Dec 1994

Option Explicit

Global sGNl As String * 2
Global sGTab As String * 1

Global sGTable As String
Global sGDbaseName As String
Global sGFormTitle As String
Global sGTempName As String
Global iGHandle As Integer
Global sGVersion  As String

'Evaluation version stuff
Global iGEvaluation As Integer


Declare Function GetTextExtent Lib "GDI" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function GetDC Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function ReleaseDC Lib "User" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Declare Function WinHelp Lib "User" (ByVal hWnd As Integer, ByVal lpHelpFile As String, ByVal wCommand As Integer, ByVal dwData As Any) As Integer
Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Integer, ByVal lpFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer
Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
Declare Function GetWindow Lib "User" (ByVal hWnd As Integer, ByVal code As Integer) As Integer
Declare Sub MoveWindow Lib "User" (ByVal hWnd As Integer, ByVal l As Integer, ByVal t As Integer, ByVal w As Integer, ByVal h As Integer, ByVal redraw As Integer)
Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Integer


Global Const WM_USER = &H400
Global Const LB_SETTABSTOPS = WM_USER + 19
Global Const WM_CLOSE = &H10
Global Const GW_CHILD = 5
Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2
Global Const GWW_HINSTANCE = (-6)



'application information
Type StdApp
    sName               As String
    sHelpFile           As String
    sIniFile            As String
    sErrorFile          As String
    sOrderInfoFile      As String
    dVersion            As Double
    sDbaseName          As String
    iToolButtonCount    As Integer
    bEvaluation         As Integer

End Type

Global tGApp    As StdApp

'returns 1 if password matches or if no password found in
'the system table
Function CheckPassword () As Integer
'     Dim Password As Variant
'
'     Err = False
'     On Error GoTo ErrorCheckPassword
'
'     mdiMain!Data1.DatabaseName = tGApp.sDbaseName
'     mdiMain!Data1.RecordSource = "Select * From System"
'     mdiMain!Data1.Options = DB_READONLY
'     mdiMain!Data1.Refresh
'     If (mdiMain!Data1.Recordset.EOF And mdiMain!Data1.Recordset.BOF) Then
'         MsgBox Error$
'         CheckPassword = 0
'         mdiMain!Data1.Database.Close
'         Exit Function
'     End If
'
'
'     Password = "" & mdiMain!Data1.Recordset.Fields("[Delete Password]")
'     mdiMain!Data1.Database.Close
'     If Password = "" Then   'no password required
'         CheckPassword = 1
'         Exit Function
'     Else    'there is a password
'         'change the caption
'         fPasswrd!lblExisting.Caption = "Please enter the password"
'         'pass the password
'         fPasswrd!lblHiddenPassword.Caption = Password
'         'make invisible the new password boxes
'         fPasswrd!lblNew1.Visible = False
'         fPasswrd!lblNew2.Visible = False
'         fPasswrd!txtNew1.Visible = False
'         fPasswrd!txtNew2.Visible = False
'         'allow entry of password
'         fPasswrd!txtExisting.Enabled = True
'         fPasswrd!txtExisting.Visible = True
'         fPasswrd!lblExisting.Enabled = True
'     End If
'
'
'     fPasswrd.Show 1
'
'     If fPasswrd.Tag = Password Then 'correct
'         CheckPassword = 1
'     Else
'         CheckPassword = 0
'     End If
'
'     Unload fPasswrd
'
' QuitCheckPassword:
'     Exit Function
'
' ErrorCheckPassword:
'     MsgBox "Error: " & Error$ & sGNl & "Unable to check password."
'     CheckPassword = 0
'     Resume QuitCheckPassword
'
End Function

'======================================================================
'Form/Module:
'   mdiMain
'
'Procedure:
'   ClearTitle
'
'Parameters
'   frmTarget   The form to set the caption on
'Modifications:
'   23/12/94   JBL     Build
'
'Description:
'   Clears the form's title
'
'======================================================================
'
Sub ClearTitle (frmTarget As Form)

    'General Error Handler
    If Not bDesignMode() Then
    On Error GoTo Error_ClearTitle
    End If


    frmTarget.Caption = tGApp.sName & " Ver. " & CStr(tGApp.dVersion)

    Exit Sub
Error_ClearTitle:
    'call the generic error handler
    GenErrorHandler "Main.bas - ClearTitle()", Err, Error$
'
    Resume Exit_ClearTitle
'
Exit_ClearTitle:

End Sub

'======================================================================
'Form/Module:
'   Main.bas
'
'Procedure:
'   GetDefaultDb
'
'Modifications:
'   25/12/94   JBL     Build
'
'Description:
'   Reads the program's ini file and tries to find the database that was
'   used last time
'======================================================================
'
Sub GetDefaultDb ()
    Dim iRetVal As Integer
    Dim sRetVal As String

    'General Error Handler
    If Not bDesignMode() Then
    On Error GoTo Error_GetDefaultDb
    End If

    'initialise
    tGApp.sDbaseName = ""

    'fill default with 80 zeros
    sRetVal = String$(80, 0)

    'read from the .ini in the user's window directory the path
    'of the current database

    iRetVal = GetPrivateProfileString("Database", "Default", " ", sRetVal, 80, tGApp.sIniFile)
    sRetVal = Trim$(sNullTrim(sRetVal))
    If sRetVal <> "" Then
    'i.e. didn't get set to the default because the section wasn't found
    If bValidDbase(sRetVal) Then
        'assign the application var to it
        tGApp.sDbaseName = sRetVal
    End If
    End If

    Exit Sub


Error_GetDefaultDb:
    'call the generic error handler
    GenErrorHandler "Main.bas - GetDefaultDb", Err, Error$
'
    Resume Exit_GetDefaultDb
'
Exit_GetDefaultDb:

End Sub

'======================================================================
'Form/Module:
'   Main.bas
'
'Procedure:
'   Main
'
'Modifications:
'   23/12/94   JBL     Build
'
'Description:
'   Initialises global vars and displays the usage form
'   if it is an evaluation version
'======================================================================
Sub Main ()
    Dim iRetVal As Integer
    Dim sRetVal As String
    Dim iUsedNumber As Integer

    'load a dummy form so that bDesignMode has something to
    'work on
    Load fDummy

'General Error Handler
    If Not bDesignMode() Then
    On Error GoTo Error_Main
    End If


    'init carriage return and tab sequences
    sGNl = Chr$(13) & Chr$(10)
    sGTab = Chr$(9)

    'set up the application structure/type
    SetAppInfo

    'init the application's helpfile
    If tGApp.sHelpFile <> "" Then
    'add in the application path to the helpfile
    tGApp.sHelpFile = APP.Path & "\" & tGApp.sHelpFile
    APP.HelpFile = tGApp.sHelpFile
    End If

    'init the application's error log file
    If tGApp.sErrorFile <> "" Then
    'add in the windows private directory path to the error file
    tGApp.sErrorFile = GetWinDir() & "\" & tGApp.sErrorFile

    'delete any existing error log file
    If bFileExists(tGApp.sErrorFile) Then
        Kill (tGApp.sErrorFile)
    End If
    End If

    If tGApp.bEvaluation And tGApp.sIniFile <> "" Then

    'fill default with 80 zeros
    sRetVal = String$(80, 0)

    'read from the ini in the user's window directory the number
    'of times they have used this program
    iRetVal = GetPrivateProfileString("Evaluation Version", "Used", " ", sRetVal, 80, tGApp.sIniFile)

    sRetVal = sNullTrim(sRetVal)
    If sRetVal <> "" Then
        iUsedNumber = CInt(sRetVal)
    Else
        iUsedNumber = 0
    End If

    iUsedNumber = iUsedNumber + 1

    'write to the ini in the user's window directory the incremented number
    'of times they have used this program
    iRetVal = WritePrivateProfileString("Evaluation Version", "Used", CStr(iUsedNumber), tGApp.sIniFile)

    'set the reminder form on top
    KeepOnTop fUsage, True
    fUsage!lblUsed.Caption = "You have used this program " & iUsedNumber
    If iUsedNumber > 1 Then
        fUsage!lblUsed.Caption = fUsage!lblUsed.Caption & " times."
    Else
        fUsage!lblUsed.Caption = fUsage!lblUsed.Caption & " time."
    End If

    fUsage.Show MODELESS
    DoEvents


    End If

    'show the main form
    mdiMain.Show
    If tGApp.bEvaluation Then
    'give the focus back to the nag screen
    fUsage.SetFocus
    End If

    Exit Sub

Error_Main:
    'call the generic error handler
    GenErrorHandler "MAIN.BAS - Main()", Err, Error$

    Resume Exit_Main

Exit_Main:

End Sub

'======================================================================
'Form/Module:
'   Main.bas
'
'Procedure:
'   NewDbase
'
'Parameters:
'   None
'
'Returns:
'   None
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Creates a new Access database then opens it
'======================================================================
Sub NewDbase ()

    SetDbase "NEW"
End Sub

'======================================================================
'Form/Module:
'   Main.bas
'
'Procedure:
'   OpenDbase
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Opens an existing Access database
'======================================================================
Sub OpenDbase ()

    SetDbase "OPEN"
End Sub

'======================================================================
'Form/Module:
'   Main.bas
'
'Procedure:
'   SetDbase
'
'Parameters:
'   sMode       NEW or OPEN
'
'Returns:
'   None
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Creates/opens an Access database
'======================================================================
'
Sub SetDbase (sMode As String)
    Dim sNewDbase As String

    'General Error Handler
    If Not bDesignMode() Then
    On Error GoTo Error_SetDbase
    End If

    'get the name of the  database
    sNewDbase = sSelectDbase(mdiMain!CMDialog1, sMode)

    If sNewDbase = "" Then Exit Sub

    'check to see if exists
    If Not bFileExists(sNewDbase) Then
    'create it
    CreateAppDbase sNewDbase
    End If
    'validate it
    If bValidDbase(sNewDbase) Then
    'set application var to it and write to  the ini file
    tGApp.sDbaseName = UCase$(sNewDbase)
    WriteDefaultDb (tGApp.sDbaseName)
    'close all mdi children
    CloseAllChildren

    're-write the main mdi form title
    SetTitle mdiMain
    End If

    Exit Sub

Error_SetDbase:
    'call the generic error handler
    GenErrorHandler "MAIN.BAS - SetDbase()", Err, Error$

    Resume Exit_SetDbase

Exit_SetDbase:


End Sub

'======================================================================
'Form/Module:
'   mdiMain
'
'Procedure:
'   SetTitle
'
'Paramters
'   frmTarget   The form to set the caption of
'Modifications:
'   23/12/94   JBL     Build
'
'Description:
'   Set's the form's title
'
'======================================================================
'
Sub SetTitle (frmTarget As Form)

    'General Error Handler
    If Not bDesignMode() Then
    On Error GoTo Error_SetTitle
    End If


    frmTarget.Caption = tGApp.sName & " Ver. " & CStr(tGApp.dVersion) & " (" & tGApp.sDbaseName & ")"

    Exit Sub
Error_SetTitle:
    'call the generic error handler
    GenErrorHandler "Main.bas- SetTitle()", Err, Error$
'
    Resume Exit_SetTitle
'
Exit_SetTitle:

End Sub

Sub WriteDefaultDb (DbasePath As String)
    Dim iRetVal As Integer

    'if an application inifile has been specified
    If tGApp.sIniFile <> "" Then
    'write to the ini file in the user's window directory the path
    'of the current database
    iRetVal = WritePrivateProfileString("Database", "Default", DbasePath, tGApp.sIniFile)
    End If
End Sub